home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Lib / palette.stk < prev    next >
Encoding:
Text File  |  1996-02-22  |  7.8 KB  |  206 lines
  1. ;;;;
  2. ;;;; Palette -- procedures that change the color palette used by Tk
  3. ;;;;
  4. ;;;; Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  5. ;;;; 
  6. ;;;; Permission to use, copy, and/or distribute this software and its
  7. ;;;; documentation for any purpose and without fee is hereby granted, provided
  8. ;;;; that both the above copyright notice and this permission notice appear in
  9. ;;;; all copies and derived works.  Fees for distribution or use of this
  10. ;;;; software or derived works may only be charged with express written
  11. ;;;; permission of the copyright holder.  
  12. ;;;; This software is provided ``as is'' without express or implied warranty.
  13. ;;;;
  14. ;;;; This software is a derivative work of other copyrighted softwares; the
  15. ;;;; copyright notices of these softwares are placed in the file COPYRIGHTS
  16. ;;;;
  17. ;;;;
  18. ;;;;           Author: Erick Gallesio [eg@unice.fr]
  19. ;;;;    Creation date:  4-Aug-1995 11:24
  20. ;;;; Last file update:  4-Aug-1995 14:07
  21. ;;;;
  22.  
  23. (require "hash")
  24.  
  25. ;; Tk:set-palette! --
  26. ;; Changes the default color scheme for a Tk application by setting
  27. ;; default colors in the option database and by modifying all of the
  28. ;; color options for existing widgets that have the default value.
  29. ;;
  30. ;; The arguments consist of either a single color name, which
  31. ;; will be used as the new background color (all other colors will
  32. ;; be computed from this) or an even number of values consisting of
  33. ;; option names and values.  The name for an option is the one used
  34. ;; for the option database, such as activeForeground, not -activeforeground.
  35.  
  36. (define Tk:set-palette!
  37.   (let ((tk::palette #f))
  38.   
  39.     (define (make-color r g b)
  40.       (let ((hexa (lambda (n) 
  41.             (string-append (number->string (quotient n 16) 16) 
  42.                    (number->string (modulo n 16) 16)))))
  43.     (string-append "#" (hexa (min (inexact->exact r) 255))
  44.                    (hexa (min (inexact->exact g) 255))
  45.                (hexa (min (inexact->exact b) 255)))))
  46.            
  47.     (define (Tk:recolor-tree w colors)
  48.       (hash-table-for-each colors 
  49.                (lambda (db-opt db-value)
  50.                  (let ((opt (make-keyword (string-lower db-opt)))
  51.                    (val #f))
  52.                    (unless (catch (set! val (tk-get w opt)))
  53.                    (if (equal? val
  54.                            (hash-table-get tk::palette db-opt))
  55.                        (tk-set! w opt db-value))))))
  56.  
  57.       ;; Do the same job for all the children
  58.       (for-each (lambda (child) (Tk:recolor-tree child colors))
  59.         (winfo 'children w)))
  60.  
  61.   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  62.   ;;;;
  63.   ;;;; Start of procedure Tk:set-palette!
  64.   ;;;;
  65.   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  66.   (lambda args
  67.     (let ((new (make-hash-table string=?)))
  68.       ;; Create a hash table that has the complete new palette. If some colors
  69.       ;; aren't specified, compute them from other colors that are specified.
  70.       (if (= (length args) 1)
  71.       (hash-table-put! new "background" (car args))
  72.       ;; place all given colors in the "new" hashatable
  73.       (for-each (lambda (x) (hash-table-put! new (car x) (cadr x))) args))
  74.  
  75.       (unless (hash-table-get new "background" #f)
  76.      (error "you must specify a background color"))
  77.  
  78.       (unless (hash-table-get new "foreground" #f)
  79.      (hash-table-put! new "foreground" "black"))
  80.  
  81.       (let* ((back      (hash-table-get new "background"))
  82.          (fore      (hash-table-get new "foreground"))
  83.          (bg        (winfo 'rgb *root* back))
  84.          (fg        (winfo 'rgb *root* fore))
  85.          (darker-bg (make-color (/ (* 9 (list-ref bg 0)) 2560)
  86.                     (/ (* 9 (list-ref bg 1)) 2560)
  87.                     (/ (* 9 (list-ref bg 2)) 2560))))
  88.     (for-each (lambda (x)
  89.             (unless (hash-table-get new x #f)
  90.                (hash-table-put! new x fore)))
  91.           (list "activeForeground" "insertBackground" 
  92.             "selectForeground" "highlightColor"))
  93.  
  94.     (unless (hash-table-get new "disabledForeground" #f)
  95.        (hash-table-put! new 
  96.                 "disabledForeground" 
  97.                 (make-color (+ (* 3 (car   bg)) (/ (car   fg) 1024))
  98.                     (+ (* 3 (cadr  bg)) (/ (cadr  fg) 1024))
  99.                     (+ (* 3 (caddr bg)) (/ (caddr fg) 1024)))))
  100.  
  101.     (unless (hash-table-get new "highlightBackground" #f)
  102.        (hash-table-put! new "highlightBackground" back))
  103.  
  104.  
  105.     (unless (hash-table-get new "activeBackground" #f)
  106.       ;; Pick a default active background that is lighter than the
  107.       ;; normal background.  To do this, round each color component
  108.       ;; up by 15% or 1/3 of the way to full white, whichever is
  109.       ;; greater.
  110.  
  111.       (let ((light (make-vector 3)))
  112.         (dotimes (i 3)
  113.            (let* ((c    (/ (list-ref bg i) 256))
  114.               (inc1 (* c 0.15))
  115.               (inc2 (/ (- 255 c) 3)))
  116.          (set! c (+ c (max inc1 inc2)))
  117.          (vector-set! light i (min c 255))))
  118.         (hash-table-put! new 
  119.                  "activeBackground" 
  120.                  (make-color (vector-ref light 0)
  121.                      (vector-ref light 1)
  122.                      (vector-ref light 2)))))
  123.  
  124.     (unless (hash-table-get new "selectBackground" #f)
  125.        (hash-table-put! new "selectBackground" darker-bg))
  126.  
  127.     (unless (hash-table-get new "troughColor" #f)
  128.        (hash-table-put! new "troughColor" darker-bg))
  129.  
  130.     (unless (hash-table-get new "selectColor" #f)
  131.        (hash-table-put! new "selectColor" "#b03060"))
  132.  
  133.     ;; Walk the widget hierarchy, recoloring all existing windows.
  134.     ;; Before doing this, make sure that the tk::palette variable holds
  135.     ;; the default values of all options, so that Tk:recolor-tree can
  136.     ;; be sure to only change options that have their default values.
  137.     ;; If the variable exists, then it is already correct (it was created
  138.     ;; the last time this procedure was invoked).  If the variable
  139.     ;; doesn't exist, fill it in using the defaults from a few widgets.
  140.  
  141.       (unless (hash-table? tk::palette)
  142.      (let ((c (checkbutton (gensym ".tmp")))
  143.            (e (entry         (gensym ".tmp")))
  144.            (s (scrollbar   (gensym ".tmp"))))
  145.  
  146.        (set! tk::palette (make-hash-table string=?))
  147.  
  148.        (hash-table-put! tk::palette "activeBackground"
  149.                 (cadddr (c 'configure :activebackground)))
  150.        (hash-table-put! tk::palette "activeForeground"
  151.                 (cadddr (c 'configure :activeforeground)))
  152.        (hash-table-put! tk::palette "background"
  153.                 (cadddr (c 'configure :background)))
  154.        (hash-table-put! tk::palette "disabledForeground"
  155.                 (cadddr (c 'configure :disabledforeground)))
  156.        (hash-table-put! tk::palette "foreground"
  157.                 (cadddr (c 'configure :foreground)))
  158.        (hash-table-put! tk::palette "highlightBackground"
  159.                 (cadddr (c 'configure :highlightbackground)))
  160.        (hash-table-put! tk::palette "highlightColor"
  161.                 (cadddr (c 'configure :highlightcolor)))
  162.        (hash-table-put! tk::palette "insertBackground"
  163.                 (cadddr (e 'configure :insertbackground)))
  164.        (hash-table-put! tk::palette "selectColor"
  165.                 (cadddr (c 'configure :selectcolor)))
  166.        (hash-table-put! tk::palette "selectBackground"
  167.                 (cadddr (e 'configure :selectbackground)))
  168.        (hash-table-put! tk::palette "selectForeground"
  169.                 (cadddr (e 'configure :selectforeground)))
  170.        (hash-table-put! tk::palette "troughColor"
  171.                 (cadddr (s 'configure :troughcolor)))
  172.  
  173.        ;; Destroy temporary widgets
  174.        (destroy c e s)))
  175.  
  176.       (Tk:recolor-tree *root* new)
  177.  
  178.       ;; Change the option database so that future windows will get the
  179.       ;; same colors. Save the options in the global variable tk::palette, 
  180.       ;; for use the next time we change the options.
  181.       (hash-table-for-each new (lambda (x y)
  182.                  (option 'add 
  183.                      (format #f "*~A" x)
  184.                      (hash-table-get new x))
  185.                  (hash-table-put! tk::palette x y))))))))
  186.  
  187. ;;
  188. ;; Tk:bisque --
  189. ;; Reset the Tk color palette to the old "bisque" colors.
  190. ;;
  191.  
  192.  
  193. (define (Tk:bisque)
  194.   (tk:set-palette! '("activeBackground"     "#e6ceb1")
  195.            '("activeForeground"     "black")
  196.            '("background"         "#ffe4c4")
  197.            '("disabledForeground"     "#b0b0b0")
  198.            '("foreground"         "black")
  199.            '("highlightBackground"     "#ffe4c4")
  200.            '("highlightColor"         "black")
  201.            '("insertBackground"     "black")
  202.            '("selectColor"         "#b03060")
  203.            '("selectBackground"     "#e6ceb1")
  204.            '("selectForeground"     "black")
  205.            '("troughColor"         "#cdb79e")))
  206.